home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr51
/
lib201.zip
/
SCREEN.PRG
< prev
next >
Wrap
Text File
|
1993-04-27
|
102KB
|
2,476 lines
*-------------------------------------------------------------------------------
*-- Program...: SCREEN.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- Notes.....: A few routines not left in PROC.PRG, these are not used as much
*-- by my own systems. See the file: README.TXT for details on how
*-- to use this library file.
*-------------------------------------------------------------------------------
FUNCTION Radio
*-------------------------------------------------------------------------------
*-- Programmer..: Ed Lafferty (CIS: 76150,3302)
*-- Date........: 06/08/1992
*-- Notes.......: Routine to create and size a popup with radio buttons
*-- for choosing only one of up to four options. Pressing
*-- the <Space Bar> on an option turns it on or off.
*-- Pressing <Enter> chooses the selected option and leaves
*-- the routine.
*-- Written for.: dBase IV, 1.1
*-- Rev. History: 02/25/1992 - original procedure.
*-- 02/27/1992 -- Ken Mayer -- added option for color, but had
*-- to take number of choices back to 4 to do so. Minor
*-- alterations performed to add color choice ... and cleaning
*-- up after self ... (original cleared the screen first ...
*-- this version saves screen, restores back to it ...) Oh yeah,
*-- I turned it into a function, rather than a procedure, as well.
*-- Calls.......: CENTER Procedure in PROC.PRG
*-- SHADOW Procedure in PROC.PRG
*-- COLORBRK() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Radio(<nULRow>,<nULCol>,<nChoice>,"<cTxt1>","<cTxt2>",;
*-- "<cTxt3>","<cTxt4>","<cTitle>","<cColor>")
*-- Example.....: cPort = Radio(8,15,1,"LPT1","LPT2","LPT3","",;
*-- "Choose a printer port","rg+/gb,n/w,rg+/gb")
*-- Returns.....: number of chosen button in nChoice
*-- Parameters..: nUlrow = upper left row of popup
*-- nUlcol = upper left column of popup
*-- nChoice = default chosen button
*-- cTxt1 = Text for 1st button
*-- cTxt2 = " " 2nd "
*-- cTxt3 = " " 3rd "
*-- cTxt4 = " " 4th "
*-- cTitle = Text for the box title
*-- cColor = Color string (i.e., "RG+/GB,N/W,RG+/GB")
*-------------------------------------------------------------------------------
parameters nUlrow, nUlcol, nChoice, cTxt1, cTxt2, cTxt3, cTxt4, ;
cTitle, cColor
private nHeight, nKey, nCnt, nWidth, cStr, cTxt0, cMidCol, cFirstCol,;
cCursor
cCursor = set("CURSOR")
store cTitle to cTxt0
save screen to sRadio
store 0 to nHeight, nKey, nCnt, nWidth
store nChoice to nOrig && in case user presses <Esc> to exit ...
*-- deal with these colors in displaying some stuff ...
cMidCol = colorbrk(cColor,2)
*-- First color (for message) is easier ...
cFirstCol = colorbrk(cColor,1)
*-- Determine height and width of popup
do case
case len(cTxt4) > 0
nHeight = 4
case len(cTxt3) > 0
nHeight = 3
case len(cTxt2) > 0
nHeight = 2
otherwise
nHeight = 1
endcase
do while nCnt <=nHeight
store "cTxt"+str(nCnt,1) to cStr
if len(&cstr) > nWidth
nWidth = len(&cStr)
endif
nCnt = nCnt + 1
enddo
*-- create popup
define window wRadio from nUlRow,nUlCol to nUlRow+nHeight+3,nUlCol+nWidth+9;
double color &cColor
do center with 23,80,"&cFirstCol","Press "+chr(24)+chr(25)+;
", <Space> to select/de-select, <Enter> to quit"
activate screen
do shadow with nULRow, nULCol, nULRow+nHeight+3, nULCol+nWidth+9
activate window wRadio
*-- display screen
store 1 to nCnt
do center with 0, nWidth+8, "", cTitle
do while nCnt <= nHeight
store "cTxt"+str(nCnt,1) to cStr
@ nCnt+1, 2 SAY "[ ]" color &cMidCol
@ nCnt+1, 6 say &cStr
nCnt = nCnt + 1
enddo
*-- prepare for and get nChoice
if nChoice > 0
store nChoice to nCnt
@nCnt+1,3 say "■" color &cMidCol
else
store 1 to nCnt
endif
store .F. to ldone
*-- this loop processes user input ...
do while .not. ldone
@ nCnt+1,3 say "" color &cMidCol
nkey = inkey(0)
do case
case nkey = 27 && Press Esc to exit
store nOrig to nChoice && Leave at "default"
store .T. to ldone
case nkey = 13
store .T. to ldone
case nkey = 32 && Press Enter or Space
set cursor off
if nChoice = nCnt
@ nCnt+1,3 say " " color &cMidCol
store 0 to nChoice
else
@ nChoice+1,3 say " " color &cMidCol
@ nCnt+1,3 say "■" color &cMidCol
store nCnt to nChoice
endif
set cursor on
case nkey = 5 && Press up arrow
if nCnt > 1
nCnt = nCnt - 1
else
nCnt = nHeight
endif
case nkey = 24 && Press down arrow
if nCnt < nHeight
nCnt = nCnt + 1
else
nCnt = 1
endif
endcase
enddo
*-- cleanup
deact window wRadio
release window wRadio
restore screen from sRadio
release screen sRadio
set message to
set cursor &cCursor
RETURN nChoice
*-- EoF: Radio()
PROCEDURE CheckBox
*-------------------------------------------------------------------------------
*-- Programmer..: Ed Lafferty (CIS: 76150,3302)
*-- Date........: 04/22/1993
*-- Notes.......: Routine to create and size a popup with check boxes
*-- for choosing any of a number (up to five) options. Pressing
*-- the <Space Bar> on an option turns it on or off.
*-- Pressing <Enter> chooses the selected option and leaves
*-- the routine. You must use a data structure with logical
*-- fields, or memvars that are logical for this. Either way,
*-- even if you don't use five logical fields/memvars, you must
*-- pass a field/memvar to the procedure -- see Example below
*-- (the logicals -- lCHK1, lCHK2, etc.-- must be fields or
*-- memvars due to a limitation in parameter passing in dBASE IV.)
*-- Written for.: dBase IV, Version 1.5+
*-- Rev. History: 02/25/1992 -- Original procedure.
*-- 02/28/1992 -- Ken Mayer -- modified to allow passing cColor,
*-- and a little cleanup of code and such. Minor changes.
*-- 04/22/1993 -- Angus Scott-Fleming:
*-- Revised for 1.5:
*-- Turned cursor on
*-- Moved help-line info inside box.
*-- Reorganized parameters to allow calling
*-- with variable # of choices, and evaluate with pCOUNT()
*-- NOTE: If more than 9 pairs are needed, two loops will
*-- have to be changed from STR(NCNT,1) to lTrim STR(cCnt,2))
*-- Enabled error-trapping for poorly located boxes.
*-- Appended "." to all &Macros.
*-- Calls.......: CENTER Procedure in PROC.PRG
*-- SHADOW Procedure in PROC.PRG
*-- COLORBRK() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do checkbox with <nULCol>,<nULRow>,<cTitle>,<cColor>,;
*-- <lchk1>,<cTxt1>,[<lchk2>,<cTxt2>];
*-- [,<lchk3>,<cTxt3>][,<lchk4>,<cTxt4>];
*-- [... to 9]
*-- Example.....: do Checkbox with 8, 15, "Choose a printer port",;
*-- "rg+/gb,w+/n,rg+/gb", lchk1, "LPT1", lchk2, "LPT2", ;
*-- lchk3, "LPT3"
*-- Returns.....: .T. for selected items, .F. for non-selected items --
*-- this routine changes the value of the logical fields passed
*-- to it.
*-- Parameters..: nULRow = upper left row of popup
*-- nULCol = upper left column of popup
*-- cTitle = Title for box
*-- cColor = Colors for window
*-- lChkn = default value of box 'n' -- MUST BE FIELDS/MEMVARS
*-- cTxtn = Text for 'n'th box
*-- cColor = Colors to be used in window ...
*-------------------------------------------------------------------------------
parameters nUlrow, nUlcol, cTitle, cColor, lChk1, cTxt1, lChk2, cTxt2,;
lChk3, cTxt3, lChk4, cTxt4, lChk5, cTxt5, lChk6, cTxt6,;
lChk7, cTxt7, lChk8, cTxt8, lChk9, cTxt9
private nHeight, nKey, nCnt, nWidth, cMidCol, cFirstCol, cCursor,;
cPrompt, nBRRow, nBRCol
*-- setup ...
cCursor = set("CURSOR")
save screen to sCheck
store 0 to nHeight, nKey, nWidth
cPrompt = "Press "+chr(24)+chr(25)+;
", <Space> to select/de-select, <Enter> to quit"
*-- save original settings, in case <Esc> gets pressed below ...
*-- determine height/width of popup
nWidth = max(len(cPrompt),len(cTitle))
nHeight = (pcount() - 4)/2
nCnt = 0
do while nCnt < nHeight
nCnt = nCnt + 1
cCnt = str(nCnt,1)
private lOrig&cCnt.
store lChk&cCnt. to lOrig&cCnt.
nWidth = max(nWidth,len(cTxt&cCnt.))
enddo
*-- add border to window
nWidth = min(nWidth+8,79)
*-- deal with some colors ...
cMidCol = colorbrk(cColor,2)
cFirstCol = colorbrk(cColor,1)
*-- create popup and trap errors defining the window
nBrRow = nULRow + nHeight + 5
nBRCol = nULCol + nWidth
if nBRRow > 24
*-- center window vertically
nULRow = max(12-(nHeight+5)/2,0)
nBRRow = min(23,(nULRow+nHeight+5))
endif
if nBRCol > 80
*-- center window horizontally
nULCol = max(40 - nWidth/2,0)
nBRCol = min(79,(nULCol+nWidth))
endif
define window wCheck from nUlrow, nUlcol to nBRRow, nBRCol;
double color &cColor.
activate screen
do shadow with nULRow,nULCol,nBRRow,nBRCol
activate window wCheck
*-- paint screen
do center with 0,nWidth,"",cTitle
store 1 to nCnt
do while nCnt <= nHeight
store "cTxt"+str(nCnt,1) to cStr
store "lChk"+str(nCnt,1) to cChk
@nCnt+1,2 say "["+iif(&cChk.,"X"," ")+"]" color &cMidCol.
@nCnt+1,6 say left(&cStr.,nWidth-9)
nCnt = nCnt + 1
enddo
do center with nCnt+2,nWidth,"",cPrompt
*-- prepare for and get nChoice
store 1 to nCnt
store .F. to ldone
do while .not. ldone
store "lChk"+str(nCnt,1) to cChk
@ nCnt+1,3 say "" color &cMidCol.
nkey = inkey(0)
do case
case nkey = 27 && Press Esc to exit
nCnt = 0
do while nCnt < nHeight
nCnt = nCnt + 1
cCnt = str(nCnt,1)
store lOrig&cCnt. to lChk&cCnt.
enddo
store .T. to ldone
case nkey = 13 && Press Enter when finished
store .T. to ldone
case nkey = 32 && Press Space
set cursor off
if &cChk. && Box was already selected,
@ nCnt+1,3 say " " color &cMidCol. && so now de-select it
store .F. to &cChk.
else && Box was not already selected,
@ nCnt+1,3 say "X" color &cMidCol. && so now select it
store .T. to &cChk.
endif
set cursor on
case nkey = 5 && Press up arrow
if nCnt > 1
nCnt = nCnt - 1
else
nCnt = nHeight
endif
case nkey = 24 && Press down arrow
if nCnt < nHeight
nCnt = nCnt + 1
else
nCnt = 1
endif
endcase
enddo
*-- Cleanup
release window wCheck
restore screen from sCheck
release screen sCheck
set message to
set cursor &cCursor.
RETURN
*-- EoP: ChkBox
FUNCTION MenuPad
*-------------------------------------------------------------------------------
*-- Programmer..: Douglas P. Saine (CIS: 74660,3574)
*-- Date........: 02/11/1992
*-- Notes.......: Used to create menu prompts of an even length. It works
*-- on any prompt - menu pads or popups.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 02/07/1992 - original function.
*-- 02/11/1992 -- Ken Mayer -- modified to truncate <cChoice>
*-- if it's longer than <nLength>.
*-- Calls.......: ALLTRIM() Function in PROC.PRG
*-- Called by...: Any
*-- Usage.......: MenuPad("<cChoice>",<nLength>)
*-- Example.....: Define pad pPad1 of mMain;
*-- prompt MenuPad("Menu Choice1",25) at 2,5
*-- Returns.....: <cChoice> padded with spaces (or truncated, if necessary)
*-- to <nLength>.
*-- Parameters..: cChoice = Menu-Pad/Popup-Bar Prompt description
*-- nLength = Length of pad/bar ...
*-------------------------------------------------------------------------------
parameters cChoice, nLength
private cReturn
if len(alltrim(cChoice)) > nLength && is it too long?
cReturn = left(cChoice,nLength) && truncate it ...
else && otherwise, pad it with spaces to the length required
cReturn = cChoice + space(nLength-len(alltrim(cChoice)))
endif
RETURN cReturn
*-- EoF: MenuPad()
FUNCTION Banner
*-------------------------------------------------------------------------------
*-- Programmer..: Dan Madoni (Borland)
*-- Date........: 09/01/1991
*-- Notes.......: This will display a left-scrolling message on the screen
*-- within the boundaries specified in the UDF by the user.
*-- It will wait for a keypress and then go away. Taken from
*-- TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 09/01/1991 -- Original
*-- Usage.......: Banner(<nRow>,<nCol>,<nWidth>,"<cMessage>","<cColor>")
*-- Example.....: ?? Banner(5,30,20,"Love your tie, is it new?","w+/r")
*-- Returns.....: Null ("")
*-- Parameters..: nRow = Leftmost ROW position of scrolled message
*-- nCol = Leftmost COL position of scrolled message
*-- nWidth = Length of displayable area starting at nRow,nCol
*-- cMessage = Message to be scrolled
*-- cColor = Color of scrolling message
*-------------------------------------------------------------------------------
parameters nRow,nCol,nWidth,cMessage,cColor
private cCursor,cTalk,cMsg,nCounter,cPause
*-- save some environment essentials
save screen to sBanner
cCursor = set("CURSOR")
cTalk = set("TALK")
set cursor off
set talk off
*-- deal with message
cMsg = space(nWidth)+cMessage+" "
nCounter = 0
*-- loop
do while .t.
nCounter = nCounter + 1
if nCounter > len(cMsg)
nCounter = 1
endif
*-- user hits any key
cPause = inkey(.15)
if cPause # 0
exit
endif
*-- display message within scrollable area
@nRow,nCol say substr(cMsg,nCounter,nWidth) color &cColor
enddo
*-- restore environment
restore screen from sBanner
release screen sBanner
set cursor &cCursor
set talk &cTalk
RETURN ""
*-- EoF: Banner()
FUNCTION SeeMatch
*-------------------------------------------------------------------------------
*-- Programmer..: Dan Madoni (Borland)
*-- Date........: 06/12/1992
*-- Notes.......: Can be included in format screen to display an instant
*-- lookup match on a particular field. A shadowed box will
*-- appear with the matching value ... Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 09/01/1991 -- Original
*-- 06/12/1992 -- Minor -- added call to RECOLOR
*-- Calls.......: RECOLOR Procedure in PROC.PRG
*-- Called by...: None
*-- Usage.......: SeeMatch("<cFile>",<cSeekExp>,"<cReturn>",<nULRow>,<nULCol>,;
*-- <nBRRow>,<nBRCol>,"<cColor>)
*-- Example.....: SeeMatch("TRAVEL",LASTNAME,"TRAVELCODE",2,40,4,60,"w+/r")
*-- Returns.....: .t.
*-- Parameters..: cFile = Database alias in which lookup will be performed.
*-- -- this file must already be USEd in some area.
*-- cSeekExp = Expression which will be SEEKed.
*-- cReturn = Name of field to contain the 'return' value.
*-- nULRow = Upper Left Row for box
*-- nULCol = Upper Left Column for box
*-- nBRRow = Bottom Right Row
*-- nBRCol = Bottom Right Column
*-- cColor = Color of box
*-------------------------------------------------------------------------------
parameters cFile,cSeeExp,cReturn,nULRow,nULCol,nBRRow,nBRCol,cColor
private cRetVal, cAttr, cStartFile
*-- store starting position ...
cStartFile = alias()
select &cFile
*-- look for a matching expression
seek cSeekExp
if found()
cRetVal = &cReturn
else
cRetVal = "<Not Found>"
endif
*-- Store current color and draw a box
cAttr = set("ATTRIBUTES")
@nULRow+1,nULCol+1 fill to nBRRow+1,nBRCol+1 color w/n && shadow
set color to &cColor
@nULRow,nULCol clear to nBRRow,nBRCol && clear out area text will go in
@nULRow,nULCol To nBRRow,nBRCol && draw box
*-- display matching expresion, and return to initial area ...
@nULRow+1,nULCol+2 say cRetVal
do ReColor with cAttr
select cStartFile
RETURN .t.
*-- EoF: SeeMatch()
FUNCTION Dialog
*-------------------------------------------------------------------------------
*-- Programmer..: Larry Quaglia (Borland)
*-- Date........: 06/09/1992
*-- Notes.......: This routine provides a 'standard' set of dialogue boxes
*-- and buttons for all applications. The concept is to provide
*-- standardization for your apps. Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 11/01/1991 -- first published in TechNotes.
*-- 06/09/1992 -- Modified to handle explicit colors, changed
*-- the color parameters a tad ... (Ken Mayer)
*-- Calls.......: SHADOW Function in PROC.PRG
*-- RECOLOR Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: Dialog("<cMsg>",<nType>,"<cBorder>",<nDefBut>,<lShadow>,;
*-- "<cWind>","<cButton>")
*-- Example.....: Dialog("We have completed the transaction.",0,"DOUBLE",;
*-- 0,.t.,"RG+/GB","W+/N")
*-- Returns.....: Character -- Either 'ERROR' or title of Button.
*-- Parameters..: cMsg = Message to be displayed -- maximum of 78 characters
*-- (one line only)
*-- nType = Dialogue box TYPE. Options are 0 to 5:
*-- 0: 'OK'
*-- 1: 'OK' 'CANCEL'
*-- 2: 'ABORT' 'RETRY' 'IGNORE'
*-- 3: 'YES' 'NO' 'CANCEL'
*-- 4: 'YES' 'NO'
*-- 5: 'RETRY' 'CANCEL'
*-- cBorder = Border Style -- options are: "" (null) for SINGLE
*-- DOUBLE or PANEL.
*-- nDefBut = Default Button.
*-- lShadow = Display with a shadow or not (both on window and
*-- buttons)?
*-- cWind = Window Colors (must be valid dBASE color combo:
*-- i.e., "RG+/GB")
*-- cButton = Highlighted Button Color (Same as above, should
*-- contrast ...)
*-------------------------------------------------------------------------------
parameters cMsg,nType,cBorder,nDefBut,lShadow,cWind,cButton
private nMsgLen,cNewColor,aButton,nMaxLine,nY,nBoxLen,nNumButton,nCounter,;
nBasex,nYCol,nMsgLoc,cCurColor
save screen to sDialog && so we can restore at end of routine
*-- determine length of message
nMsgLen = len(trim(ltrim(cMsg))) + 1
*-- Check for valid parms
do case
case nMsgLen > 78
RETURN "ERROR - Message Length"
case .not. (upper(cBorder) = "DOUBLE" .or. upper(cBorder) = "PANEL" .or.;
len(trim(cBorder)) = 0)
RETURN "ERROR - Border"
endcase
*-- save current color info and set color to user-defined
cCurColor = set("ATTRIBUTES")
set color of normal to &cWind
set color of box to &cWind
set color of message to &cWind
set color of highlight to &cButton
*-- Allow use of <Tab> to move from button to button
on key label tab keyboard chr(4) && act as if right arrow were pushed
*-- Define button array -- max of 3 buttons (at the moment)
declare aButton[3]
aButton[1] = ""
aButton[2] = ""
aButton[3] = ""
*-- Establish screen height to properly center dialogue box
nMaxLine = iif(right(set("DISP"),2) = "43",43,24)
*-- Determine length of passed "message" parameter. If long enough, make
*-- the dialog box a little bigger. If very short, make it just big
*-- enough to accomodate the three buttons.
nY = iif(int(nMsgLen) > 30,int(nMsgLen/2)+2,24)
nBoxLen = 2 * nY
*-- Setup the window and determine if shadow ... if yes, call shadow
define window wDialog from int(nMaxLine/2)-5,40-nY to ;
int(nMaxLine/2)+4,40+nY &cBorder
if lShadow
activate screen
do shadow with int(nMaxLine/2)-5,40-nY,int(nMaxLine/2)+4,40+nY
endif
activate window wDialog
clear
*-- Determine the type of buttons and set appropriate parms.
*-- These could be modified to your own needs.
do case
case nType = 0
nNumButton = 1
aButton[1] = " OK "
case nType = 1
nNumButton = 2
aButton[1] = " OK "
aButton[2] = " CANCEL "
case nType = 2
nNumButton = 3
aButton[1] = " ABORT "
aButton[2] = " RETRY "
aButton[3] = " IGNORE "
case nType = 3
nNumButton = 3
aButton[1] = " YES "
aButton[2] = " NO "
aButton[3] = " CANCEL "
case nType = 4
nNumButton = 2
aButton[1] = " YES "
aButton[2] = " NO "
case nType = 5
nNumButton = 2
aButton[1] = " RETRY "
aButton[2] = " CANCEL "
endcase
*-- Get dialog box length to create a bar menu of appropriate size.
*-- Define the bar menu in a loop. Deactivate it upon selection of
*-- one of the buttons.
nCounter = 1
nBaseX = nBoxLen / (nNumButton + 1)
define menu mDialog
do while nCounter <= nNumButton
pPadName = "PAD"+str(nCounter,1) && pad name is 'PAD #'
nYCol = (nCounter * nBaseX) - (int(len(aButton[nCounter]) /2))
define pad &pPadName of mDialog prompt aButton[nCounter] at 4,nYCol
*-- If shadow is on, put shadows on buttons as well ...
if lShadow
activate screen
do shadow with 3,nYCol-2,5,nYCol+(len(aButton[nCounter]))-1
endif
@3,nYCol-1 to 5,nYCol+(len(aButton[nCounter])) && box around button
on selection pad &pPadName of mDialog deactivate menu
nCounter = nCounter + 1
enddo
*-- place message (centered in box)
nMsgLoc = int(nBoxLen/2) - int(nMsgLen/2)
@1,nMsgLoc say cMsg
*-- place cursor to the default button specified by the user
nCounter = 1
do while nCounter < nDefBut
keyboard chr(4)
nCounter = nCounter + 1
enddo
*-- Activate the whole thing, and return the button name
activate menu mDialog
cValue = trim(ltrim(prompt()))
*-- deactivate it all, restore screen, etc.
deactivate window wDialog
release window wDialog
release menu mDialog
restore screen from sDialog
release screen sDialog
do ReColor with cCurColor
on key label tab
RETURN cValue
*-- EoF: Dialog()
FUNCTION MsgExp
*-------------------------------------------------------------------------------
*-- Programmer..: Adam Menkes (Borland)
*-- Date........: 02/05/1993
*-- Notes.......: Allows you to display message (or error message), centered
*-- like SET MESSAGE ... with added utility. Does not use
*-- "(Press Space)", which can be annoying. The message and the
*-- line on which it is displayed will be the same color.
*-- Taken from TECHNOTES.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 09/01/1991 -- Original routine
*-- 02/05/1993 -- Modified by Lee Hite to handle a string that
*-- is greater than 80 characters (this can be
*-- a real problem if the message is in row 24!)
*-- Usage.......: MsgExp("<cExp>")
*-- Example.....: MsgExp("This is a message")
*-- Returns.....: Message displayed (centered) on screen
*-- Parameters..: cExp = Message to be displayed
*-------------------------------------------------------------------------------
parameters cMsg
private nLen
nLen = (80-len(trim(cMsg)))/2
RETURN space(nLen) + trim(cMsg) + space(nLen+0.5)
*-- EoF: MsgExp
FUNCTION YesNoCan
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 02/01/1993
*-- Notes.......: Asks a yes/no/cancel question in a dialog window/box
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
*-- 04/29/1991 - Modified to Ken Mayer add shadow
*-- 05/13/1991 - Modified to Ken Mayer remove need for extra
*-- procedures (YES/NO) that were used for returning
*-- values from Menu
*-- (suggested by Clinton L. Warren (VBCES))
*-- 01/20/1992 - Modified by Martin Leon (HMan) to handle user
*-- pressing 'Y' or 'N' keys (with ON KEY ...).
*-- 06/11/1992 - Modified by Joey Carroll (JOEY) to allow
*-- answer choices to be "Yes", "No", or "Cancel"
*-- or to allow for parameters to pass the contents
*-- of the prompts. If none are passed, they default
*-- to "Yes", "No", "Cancel". Further modified to
*-- allow specification of location by row if
*-- desired. Window size now varies as parameters
*-- dictate.
*-- 09/21/1992 - Modified by JOEY to fix bug caused if leading
*-- blanks in parameters cPrompt1,cPrompt2,cPrompt3
*-- Corrected example - case pad()="PPAD1"
*-- instead of case pad()=PPAD1
*-- 02/01/1993 - Mods by Lee Hite: Routine would not wait for
*-- user response if "default" answer did not match
*-- one of the prompts. Now first prompt becomes
*-- default if no match is found on invocation.
*-- Also, match is no longer case sensitive. Also
*-- made window height variable if message
*-- lines 2 and/or 3 are null strings. Finally,
*-- added "confirmation" parameter which when set
*-- true will force user to press [Enter] before
*-- function returns.
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- ISBLANK() Function in MISC.PRG, Internal in 1.5
*-- Called by...: Any
*-- Usage.......: YesNoCan("<cAnswer>","<cMess1>","<cMess2>","<cMess3>",;
*-- "<cPrompt1>","<cPrompt2>","<cPrompt3>",;
*-- <nTopRow>,"<cColor>",[lConfirm])
*-- Example.....: cAnswer="Y"
*-- cAnswer=YesNoCan(cAnswer,"*** Warning ***",;
*-- "A serious error has occured.",;
*-- "Choose carefully.","Proceed",;
*-- "Retry","Cancel",10,;
*-- "w+/r,n/w,w+/r")
*-- do case
*-- case cAnswer="Y" && OR case pad()="PPAD1"
*-- * do your thing
*-- case cAnswer="N" && OR case pad()="PPAD2"
*-- skip
*-- case cAnswer="C" && OR case pad()="PPAD3"
*-- * e.g. - return
*-- endcase
*--
*-- The middle set of colors should be different, as they
*-- will be the colors of the YES/NO selections ...
*-- Options may be blank by using nul values ("")
*-- Returns.....: First character of selected pad
*-- Parameters..: cAnswer = default value (Yes or No or Cancel) for menu
*-- cMess1 = First line of Message
*-- cMess2 = Second line of message
*-- cMess3 = Third line of message
*-- cPrompt1 = Optional prompt for left pad
*-- cPrompt2 = Optional prompt for middle pad
*-- cPrompt3 = Optional prompt for right pad
*-- nTopRow = Optional top row of window
*-- cColor = Optional colors for window/menu/box
*-- lConfirm = Optional "confirmation" parameter -- if true
*-- user must press [Enter], otherwise pressing
*-- a valid prompt key automatically returns
*-------------------------------------------------------------------------------
parameter cAnswer,cMess1,cMess2,cMess3,;
cPrompt1,cPrompt2,cPrompt3,nTopRow,cColor,lConfirm
private nLMargin,nRMargin,lWrap,nTopRowMax,cKey1,cKey2,cKey3,nWinWidth, ;
cConfirm, nWinHgth, nMsgRow
private cPrompt1,cPrompt2,cPrompt3
*-- save screen so we can restore ...
save screen to sYesNoCan
* locate top row of window
nTopRowMax = iif(set("STATUS") = "OFF",17,14) && protect Status Line
nTopRow = iif(isblank(nTopRow),14,nTopRow) && no parameter passed
nTopRow = min(nTopRowMax,nTopRow)
* set pad prompts if none passed
cPrompt1 = iif(isblank(cPrompt1),"Yes",cPrompt1)
cPrompt2 = iif(isblank(cPrompt2),"No",cPrompt2)
cPrompt3 = iif(isblank(cPrompt3),"Cancel",cPrompt3)
cAnswer = iif(isblank(cAnswer),cPrompt1,cAnswer)
* program bombs if prompts passed contain leading blanks
cPrompt1 = ltrim(trim(cPrompt1))
cPrompt2 = ltrim(trim(cPrompt2))
cPrompt3 = ltrim(trim(cPrompt3))
* determine how wide the window needs to be
nWinWidth = max(19,len(cPrompt1 + cPrompt2 + cPrompt3) +13)
nWinWidth = max(nWinWidth,len(cMess1)+4)
nWinWidth = max(nWinWidth,len(cMess2)+4)
nWinWidth = max(nWinWidth,len(cMess3)+4)
* and how high it needs to be
nWinHgth = iif(""=cMess2,7,8)
nWinHgth = iif(""=cMess3,nWinHgth-1,nWinHgth)
* and center it
define window wYesNoCan from nTopRow,40-(nWinWidth+2)/2 ;
to nTopRow+nWinHgth-1,40+(nWinWidth+2)/2 double color &cColor.
define menu mYesNoCan
define pad pPad1 of mYesNoCan Prompt "["+cPrompt1+"]" ;
at nWinHgth-3,02
* center middle prompt between other two, not center of window
define pad pPad2 of mYesNoCan Prompt "["+cPrompt2+"]" at nWinHgth-3, ;
((nWinWidth-len(cPrompt2))/2+(len(cPrompt1)-len(cPrompt3))/2)
define pad pPad3 of mYesNoCan Prompt "["+cPrompt3+"]" ;
at nWinHgth-3,(nWinWidth-3)-(len(cPrompt3))
on selection pad pPad1 of mYesNoCan deactivate menu
on selection pad pPad2 of mYesNoCan deactivate menu
on selection pad pPad3 of mYesNoCan deactivate menu
activate screen
do shadow with nTopRow,40-(nWinWidth+2)/2,nTopRow+nWinHgth-1, ;
40+(nWinWidth+2)/2
activate window wYesNoCan
do center with 0,nWinWidth,"",cMess1 && center the text
*-- deal with blank message lines
nMsgRow = 2
if "" <> cMess2
do center with nMsgRow,nWinWidth,"",cMess2
nMsgRow = nMsgRow + 1
endif
if "" <> cMess3
do center with nMsgRow,nWinWidth,"",cMess3
endif
*-- deal with user pressing first key of prompt
cKey1 = left(cPrompt1,1)
cKey2 = left(cPrompt2,1)
cKey3 = left(cPrompt3,1)
*-- set [CR] at end of keyboard command depending on "confirm" parameter
cConfirm = iif(lConfirm,"",chr(13))
on key label &cKey1. keyboard iif( PAD() = "PPAD1", "", ;
iif(pad() = "PPAD2", chr(19),CHR(4) )) + cConfirm
on key label &cKey2. keyboard iif( PAD() = "PPAD2", "", ;
iif(pad() = "PPAD1",CHR(4),chr(19) )) + cConfirm
on key label &cKey3. keyboard iif( PAD() = "PPAD3", "", ;
iif(pad() = "PPAD2", CHR(4),chr(19))) + cConfirm
clear typeahead
*-- otherwise deal with regular "menu" abilities
do case
case upper(cAnswer)=upper(cKey1)
activate menu mYesNoCan pad pPad1
case upper(cAnswer)=upper(cKey2)
activate menu mYesNoCan pad pPad2
case upper(cAnswer)=upper(cKey3)
activate menu mYesNoCan pad pPad3
otherwise
activate menu mYesNoCan pad pPad1
endcase
*-- clear out ON KEY settings ...
on key label &cKey1.
on key label &cKey2.
on key label &cKey3.
*-- reset environment
deactivate window wYesNoCan
release window wYesNoCan
restore screen from sYesNoCan
release screen sYesNoCan
release menu mYesNoCan
RETURN upper(substr(prompt(),2,1))
*-- EoF: YesNoCan()
PROCEDURE ProgBar2
*-------------------------------------------------------------------------------
*-- Programmer..: Joey D. Carroll (JOEY)
*-- Date........: 10/26/1992
*-- Notes.......: A crippled version of PROGBAR for those who want it simple.
*-- A visual indicator of program activity, i.e. shows
*-- user program didn't die during long processes which
*-- do not normally show 'on screen'. Serves same purpose
*-- as MONITOR, but is more graphic.
*-- For best appearance, set cursor 'off' from calling
*-- program, outside of the loop which calls PROGBAR.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/28/1992 -- Original
*-- 10/26/1992 -- protected existing active window.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do PROGBAR2 with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>
*-- Example.....: *-- determine what process will be monitored and what the
*-- *-- final value will be, e.g. nReccount = reccount()
*-- use <anyfile>
*-- nReccount = reccount()
*-- set cursor off
*-- scan
*-- do progbar2 with nReccount,",,w+/n","w+/r","w+/g"
*-- *-- do some needed process here
*-- endscan
*-- *-- cleanup
*-- Returns.....: None
*-- Parameters..: nQuan = maximum number of iterations
*-- cWindCol = the window colors
*-- cFillCol1 = color of ruler before process
*-- cFillCol2 = color of ruler after process
*-------------------------------------------------------------------------------
parameters nQuan,cWindCol,cFillCol1,cFillCol2 && e.g. how many records
private nWindWidth
nWindWidth = 78 && hard coded, wall to wall
*-- skip this section if we've been here before
*-- this procedure called from inside a loop
*-- following section ignored except on first iteration thru loop
if type("nTimes") = "U"
save screen to sProgBar
public nFactor,nTimes,wPrevWind
wPrevWind = window()
if set("status") = "ON" && different location if status "on"
define window wProgBar from 19,0 to 21,79 double color &cWindCol
else
define window wProgBar from 21,0 to 23,79 double color &cWindCol
endif && set("status") = "ON"
activate window wProgBar
@ 0,0 say replicate(".",nWindWidth - 1) && the ruler
@ 0,0 say "0%" && and some gradation %'s
@ 0,nWindWidth / 4 - 2 say "25%"
@ 0,nWindWidth / 2 - 2 say "50%"
@ 0,3*(nWindWidth / 4) - 2 say "75%"
@ 0,nWindWidth - 4 say "100%"
@ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1 && color of ruler before process
nFactor = nQuan/nWindWidth && e.g. how many records per bar part(cols)
nTimes = 0 && times thru loop
endif && type("nTimes") = "U"
*-- the section will be processed as many times as required by nQuan
nTimes = nTimes+1
@ 0,0 fill to 0,int(nTimes/nFactor) ;
- iif(int(nTimes/nFactor) -1 >= 0,1,0) ;
color &cFillCol2 && color of ruler as processing takes place
if nTimes = nQuan && we done
x = inkey(.5) && leave on screen just a liitle while after completion
* cleanup your mess
deactivate window wProgBar
release window wProgBar
restore screen from sProgBar
release screen sProgBar
*-- if window was active, re-activate
if .not. isblank(wPrevWind)
activate window wPrevWind
endif
release nProgBar,nFactor,nTimes,nWindWidth,x,wPrevWind
endif
RETURN
*-- EoP: PROGBAR2
PROCEDURE MovePad
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*-- Date........: 07/29/1992
*-- Notes.......: Used to move the selected pad in a dBASE Bar Menu if the user
*-- selects the first letter/key of the pad. The routine doesn't
*-- re-evalute PAD(), and is based on Genifer code (improved on
*-- by Angus). This should be used with the ON KEY command.
*-- NOTE: This routine assumes you are using the dUFLP/dHUNG
*-- standard for naming pads, and that the first character of
*-- each pad NAME is 'p' (i.e., pColor, pExit, etc.).
*-- Written for.: dBASE IV, 1.5, should work in 1.1.
*-- Rev. History: 07/24/1992 -- Original
*-- 07/29/1992 -- Added header/notes.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do MovePad with <cLetter>,<lSelect>,<cChoices>
*-- Example.....: on key label "C" do MovePad with "C",.t.,cChoices
*-- Returns.....: None
*-- Parameters..: cLetter = first letter/key on pad
*-- lSelect = select pad, or move cursor to it? (Act as if user
*-- pressed <Enter> after moving to it?)
*-- cChoices = list of possible choices (i.e.,
*-- "Enter,Edit,Delete,Print,Exit")
*-------------------------------------------------------------------------------
parameters cLetter, lSelect, cChoices
private nToMove
*-- determine how many pads to move, based on position of choice in list
*-- of choices (cChoices).
nToMove = at(cLetter,cChoices) - at(substr(pad(),2,1),cChoices)
*-- if it is a negative value, move to the left, and press <Enter> if
*-- lSelect = .t. (otherwise, just move there and stop).
if nToMove < 0
keyboard replicate(chr(5), -nToMove) + iif(lSelect,chr(13),"")
else
keyboard replicate(chr(24), nToMove) + iif(lSelect,chr(13),"")
endif
RETURN
*-- EoP: MovePad
PROCEDURE Monitor
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 06/08/1992
*-- Notes.......: Displays a status message to monitor a long-running
*-- operation that operates on multiple records . . .
*-- Should be used with MONITOROFF (below) to cleanup.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow
*-- 06/08/1992 - Modified to handle explicit color setting
*-- Calls.......: SHADOW Procedure in PROC.PRG
*-- CENTER Procedure in PROC.PRG
*-- Called by...: Any
*-- Usage.......: do monitor with "<cText>","<cColor>"
*-- Example.....: do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
*-- nRec = 0
*-- do while && (or SCAN)
*-- && stuff -- process records
*-- nRec = nRec + 1
*-- @4,30 display ltrim(str(nRec)) && current record
*-- && in window MONITOR
*-- enddo && (or endscan)
*-- do MonitorOff && procedure to clean-up after this one
*-- Returns.....: None
*-- Parameters..: cText = Text to display
*-- cColor = Colors for window
*-------------------------------------------------------------------------------
parameters cText,cColor
private cTempCol
save screen to sMonitor
activate screen
define window wMonitor From 10,10 to 18,70 double color &cColor
do shadow with 10,10,18,70
activate window wMonitor
do center with 1,60,"",cText
do center with 2,60,"","Please do not interrupt"
@4,10 say "Working on record of " + ltrim(str(reccount(),5))
RETURN
*-- EoP: Monitor
PROCEDURE MonitorOff
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/1991
*-- Notes.......: Used to deal with ending routines for MONITOR
*-- procedure above.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991 -- Original
*-- Calls.......: None
*-- Called by...: Routine using MONITOR Procedure in PROC.PRG
*-- Usage.......: do monitoroff
*-- Example.....: do monitoroff
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
deactivate window wMonitor
release window wMonitor
restore screen from sMonitor
release screen sMonitor
RETURN
*-- EoP: MonitorOff
FUNCTION NewBorder
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 01/20/1993
*-- Notes.......: Will save current border setting (the returned value),
*-- and set a new one with one of a set of pre-defined
*-- borders. This will create a new variable if it doesn't
*-- already exist, called: c_Border, which is a PUBLIC Character
*-- variable. The purpose is so that you can keep using this
*-- string for other purpose (i.e., DEFINE WINDOW and such ...)
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/20/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NewBorder("<cStyle>")
*-- Example.....: cOldBorder = NewBorder("K")
*-- @5,10 to 15,60 && draw box with new "border" setting
*-- *-- define a window with new "border" setting
*-- define window wTest from 10,20 to 20,60 &c_Border
*-- set border to &cOldBorder && reset border to original
*-- Returns.....: Current border setting (before calling routine)
*-- Parameters..: cStyle = Style from one of the following:
*-- A = Double
*-- ╔════╗
*-- ║ ║
*-- ╚════╝
*-- B = Single
*-- ┌────┐
*-- │ │
*-- └────┘
*-- C = Panel
*-- ██████
*-- █ █
*-- ██████
*-- D = None
*-- E = Double Top, Single Left, Right, and Bottom
*-- ╒════╕
*-- │ │
*-- └────┘
*-- F = Single Top, Double Left, Right and Bottom
*-- ╓────╖
*-- ║ ║
*-- ╚════╝
*-- G = Double Top, Left, Right, Single Bottom
*-- ╔════╗
*-- ║ ║
*-- ╙────╜
*-- H = Single Top, Left, Right, Double Bottom
*-- ┌────┐
*-- │ │
*-- ╘════╛
*-- I = Double Top, Single Left and Right, Double Bottom
*-- ╒════╕
*-- │ │
*-- ╘════╛
*-- J = Single Top, Double Left and Right, Single Bottom
*-- ╓────╖
*-- ║ ║
*-- ╙────╜
*-- K = Single Top and Left, Double Right and Bottom
*-- ┌────╖
*-- │ ║
*-- ╘════╝
*-- L = Single Top, Double Left, Single Right, Dbl Bottom
*-- ╓────┐
*-- ║ │
*-- ╚════╛
*-- M = Double Top and Left, Single Right and Bottom
*-- ╔════╕
*-- ║ │
*-- ╙────┘
*-- N = Double Top, Single Left, Double Right, Sgl Bottom
*-- ╒════╗
*-- │ ║
*-- └────╜
*-- O = Double Top, Single Left, Double Right and Bottom
*-- ╒════╗
*-- │ ║
*-- ╘════╝
*-- P = Double Top, Left, Single Right, Double Bottom
*-- ╔═════╕
*-- ║ │
*-- ╚═════╛
*-- Q = Single Top, Double Left, Single Right and Bottom
*-- ╓─────┐
*-- ║ │
*-- ╙─────┘
*-- R = Single Top and Left, Double Right, Single Bottom
*-- ┌─────╖
*-- │ ║
*-- └─────╜
*-- S = Panel, but with more room on the interior ...
*-- the default 'panel' mode for borders uses
*-- ASCII 219 (alla way around), where this
*-- uses 220-223 ...
*-- ▐▀▀▀▀▀▌
*-- ▐ ▌
*-- ▐▄▄▄▄▄▌
*-------------------------------------------------------------------------------
parameters cStyle
cReturn = set("BORDER") && current border -- if version of dBASE is
&& less than 1.5, comment this out ...
if type("c_Border") = "U" && if this is undefined
public c_Border && declare it as public
endif
*-- here we go ...
do case
case cStyle = "A"
c_Border = "DOUBLE" && pre-defined
case cStyle = "B"
c_Border = "SINGLE" && pre-defined
case cStyle = "C"
c_Border = "PANEL" && pre-defined
case cStyle = "D"
c_Border = "NONE" && pre-defined
case cStyle = "E"
*-- items are: top line, bottom line, left line, right line,
*-- upper left corner, upper right corner, bottom left corner,
*-- bottom right corner
c_Border = "205,196,179,179,213,184,192,217"
case cStyle = "F"
c_Border = "196,205,186,186,214,183,200,188"
case cStyle = "G"
c_Border = "205,196,186,186,201,187,211,189"
case cStyle = "H"
c_Border = "196,205,179,179,218,191,212,190"
case cStyle = "I"
c_Border = "205,205,179,179,213,184,212,190"
case cStyle = "J"
c_Border = "196,196,186,186,214,183,211,189"
case cStyle = "K"
c_Border = "196,205,179,186,218,183,212,188"
case cStyle = "L"
c_Border = "196,205,186,179,214,191,200,190"
case cStyle = "M"
c_Border = "205,196,186,179,201,184,211,217"
case cStyle = "N"
c_Border = "205,196,179,186,213,187,192,189"
case cStyle = "O"
c_Border = "205,205,179,186,213,187,212,188"
case cStyle = "P"
c_Border = "205,205,186,179,201,184,200,190"
case cStyle = "Q"
c_Border = "196,196,186,179,214,191,211,217"
case cStyle = "R"
c_Border = "196,196,179,186,218,183,192,189"
case cStyle = "S"
c_Border = "223,220,222,221,222,221,222,221"
endcase
set border to &c_Border
RETURN cReturn
*-- EoF: NewBorder
FUNCTION VidRow
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*-- to return the ABSOLUTE position of the current ROW on the
*-- screen, despite any active windows, etc.
*-- This is based on original routines by David Frankenbach,
*-- but includes the load/release in one routine, rather
*-- than requiring three functions to perform this ...
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidRow()
*-- Example.....: ?VidRow()
*-- Returns.....: Numeric ROW position for current row on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cX
cX = space(2) && define argument memvar
load vdcursor && load the .BIN file
call vdcursor with cX && call it with the memvar
release module vdcursor && release from memory
RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
*-- EoF: VidRow()
FUNCTION VidCol
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 01/28/1993
*-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
*-- to return the ABSOLUTE position of the current COLUMN on the
*-- screen, despite any active windows, etc.
*-- This is based on original routines by David Frankenbach,
*-- but includes the load/release in one routine, rather
*-- than requiring three functions to perform this ...
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/28/1993 -- Original
*-- Calls.......: VDCURSOR.BIN
*-- Called by...: Any
*-- Usage.......: VidCol()
*-- Example.....: ?VidCol()
*-- Returns.....: Numeric COLUMN position for current Col on screen
*-- Parameters..: None
*-------------------------------------------------------------------------------
private cX
cX = space(2) && define argument memvar
load vdcursor && load the .BIN file
call vdcursor with cX && call it with the memvar
release module vdcursor && release from memory
RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
*-- EoF: VidCol()
FUNCTION PwdMask
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer
*-- Date........: 01/29/1993
*-- Notes.......: Designed to display a mask on the screen when a user is
*-- entering a password, rather than a blank surface. Should
*-- handle backspaces to delete ... ASSUMES <cField> is a
*-- memvar.
*-- ***************************
*-- ** REQUIRES VDCURSOR.BIN **
*-- ***************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/29/1993 -- Original
*-- Calls.......: VidRow() Function in SCREEN.PRG
*-- VidCol() Function in SCREEN.PRG
*-- Called by...: Any
*-- Usage.......: PwdMask("<cField>"[,<nMaskChar>])
*-- Example.....: @5,10 get password when PwdMask("Password");
*-- valid required .not. isblank(password);
*-- error chr(7)+"Password cannot be blank)
*-- Returns.....: .T., and field will have password placed in it when done.
*-- Parameters..: cField = name of the field
*-- nMaskChar = ASCII code for mask character. OPTIONAL parameter.
*-- if not provided, will use asterisk. Suggested
*-- characters include: 176,177,178,219,248,249,254
*-- ░ ▒ ▓ █ ° ∙ ■
*-------------------------------------------------------------------------------
parameters cField, nMaskChar
private nLength, nChar, nX
*-- deal with mask character
if type("NMASKCHAR") = "L"
nMaskChar = 42 && *
endif
lCursor = set("CURSOR") = "ON"
set cursor off && rather than have the cursor in the way ...
nLength = len(&cField.) && get length of current field
nChar = 0 && input character
nRow = vidrow() && get absolute cursor location
nCol = vidcol() && ditto
cTemp = "" && initialize temp memvar
do while len(cTemp) < nLength .and. nChar # 13
&& loop until we hit end of field
&& or user presses <Enter>
nChar = inkey(0) && wait for user to enter something
do case
case nChar = 127 && <BackSpace>
if isblank(cTemp) && if empty, don't delete anything
?? chr(7) && instead, BEEP
else
cTemp = left(cTemp,len(cTemp)-1) && backup one
endif
case (nChar => 65 .and. nChar <= 90) .or.;
(nChar => 97 .and. nChar <= 122) && alphabetic input only
cTemp = cTemp + chr(nChar) && add character
case nChar = 13 && <Enter>
exit
otherwise
?? chr(7) && otherwise, BEEP
loop
endcase
*-- create the current "mask", padding with spaces ...
cMask = replicate(chr(nMaskChar),len(cTemp)) + space(nLength-len(cTemp))
*-- display it in same color as the current "GET"
@nRow,nCol get cMask
clear gets
*-- put password into current memvar
store cTemp to &cField.
enddo
*-- turn cursor on if it was prior to this routine
if lCursor
set cursor on
endif
keyboard chr(13) && send a final <Enter> to exit this GET
RETURN .T.
*-- EoF: PwdMask()
PROCEDURE MultiPick
*----------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 02/06/1993
*-- Notes.......: Permits selecting 0 or more elements of an array.
*-- The array must contain two columns, the first of which
*-- contains the prompt for the row and the second of which
*-- contains logical .T. if the row is selected by default,
*-- or .F. Array may contain additional columns.
*-- This is written for programmers, not end users.
*-- It assumes the active window and border style are set before
*-- it is called, and no error handling is provided for
*-- attempts to write outside the current window, impossible
*-- colors, truncation of prompts or other calling errors that
*-- should become evident on testing.
*--
*-- If array contains elements "Hydrangea",.T. and "Tulip",.F.,
*-- initial display after setting a window and calling will be
*-- something like this:
*--
*-- [ √ ] Hydrangea
*-- [ ] Tulip
*--
*-- This program will use the mouse if two conditions exist:
*-- 1) The variable nG_MusClic must exist and must hold the
*-- inkey() value of the character "keyboarded" for a click
*-- by the mouse-event handler. Note that this is often, but
*-- need not be, the same as asc( <character> ).
*-- 2) The mouse must be made active and visible by a
*-- mouse-control .bin such as JPMOUSE.BIN and MUSCLICK.BIN
*-- must be loaded and installed.
*-- *******************************
*-- **** REQUIRES MUSCLICK.BIN ****
*-- **** JPMOUSE.BIN ****
*-- **** VDCURSOR.BIN ****
*-- *******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 01/16/93 - original procedure
*-- 02/06/93 - revised to use cWnSize, etc.
*-- 02/24/93 - parameters changed, functions called moved out
*-- 02/28/93 - symbolic constants and support for tab added
*-- Calls.......: SMultPick Child procedure to paint screen
*-- Arrayrows() Function in Array.prg
*-- MUSCLICK.BIN Binary mouse-event handler
*-- CWnSize() Function to find window size
*-- CWnDecode() Function to decode the above
*-- YnMouse() Yesno function for mouse
*-- NormColors() Function to return normal colors
*-- HighColors() Function to return highlight colors
*-- ForeColor() Function to return foreground color
*--
*-- Called by...: Any
*-- Usage.......: DO Multipick WITH <cArray>,<nDown>,<nLast>,<nRows>,<nLength>
*-- [, <cColors> [, <cCheck> ] ]
*-- Example.....: DO Multipick WITH "Myarray",3,15,10,18,"RG+/G,N/W",chr(2)
*-- Parameters..: cArray = Name of the array of selectable items. See
*-- Notes, above, for required structure.
*-- nDown = first useable row of window
*-- nLast = last useable row of window
*-- nRows = number of items to show on screen at once
*-- nLength = maximum length of prompts
*-- cColors = optional, colors to use for noncurrent
*-- and current items. Default is NORMAL and
*-- HIGHLIGHT colors for the current window.
*-- Pass default as .F. if cCheck is included.
*-- cCheck = optional, character to use to show selection.
*-- Default is "√". See "cBox" variables in the
*-- procedure for bracketing characters.
*-- Also uses...: global numeric variable nG_MusClic, giving the inkey()
*-- value of the character "keyboarded" by a mouse click.
*-- If this variable does not exist, mouse support is absent.
*-- Side effects: On return, the values of the second column of the array
*-- are .T. or .F. in accordance with selections made.
*-- Special note: The CWnSize function called by this routine uses
*-- VDCURSOR.BIN, which must be available for this routine
*-- to work, and disables any ON ERROR trap.
*-------------------------------------------------------------------------------
parameters cArray, nDown, nLast, nRows, nLength, cColors, cCheck
private cChar, cCols, cNorm, cHigh, nAt, nTop, nKey, cBoxl, cBoxr
private nElems, lGotMouse, nMTop, nMBot, nMLeft, nMRight, cCols
private cMrow, cMcol, nMrow, nMcol, cEsc, cWin, nWinTop, nWinLeft
private nWinBot, nWinRight, nK, cK, cTemp, nX, cQuit, nRo, lOnPicks
private lOk
* These "symbolic constants" are C-style, just to avoid "magic
* numbers" scattered throughout the routine. Of course, they
* may also slow it down absent a true compiler
private NBOXLEN, NEXTRAROWS, NPADLEN, NTWOPADS
NBOXLEN = 6 && length of the "[ √ ] " structure
NEXTRAROWS = 4 && blank row at top, 3 rows for quit pads
NPADLEN = 6 && length of the OK and Cancel pads
NTWOPADS = 13 && length of two pads and a space between
* set escape
cEsc = set("ESCAPE")
set escape off
* set delimiter chars
cBoxl = "[ "
cBoxr = " ] "
* set colors if specified
if type( "cColors" ) = "C"
cCols = cColors
else
cCols = set( "ATTRIBUTES" )
cCols = left( cCols, at( "&", cCols ) - 2 )
endif
cNorm = NormColors( cCols )
cHigh = HighColors( cCols )
* set up quit pad colors
cQuit = cHigh
* set checkmark char, default is "√" ( chr( 251 ) )
cChar = iif( type( "cCheck" ) # "L", cCheck, "√" )
* calculate array rows and set up temporary array for restoration
nElems = arrayrows( cArray )
declare cTemp[ nElems ]
nX = 1
do while nX <= nElems
cTemp[ nX ] = &cArray[ nX, 2 ]
nX = nX + 1
enddo
* find borders of current window and determine centering offset
cWin = cWnSize()
if len( cWin ) > 0
nWinTop = cWnDecode( cWin, "T" )
nWinLeft = cWnDecode( cWin, "L" )
nWinBot = cWnDecode( cWin, "B" )
nWinRight = cWnDecode( cWin, "R" )
else
activate screen
? "Can't find VDCURSOR.BIN - aborting"
wait
cancel
endif
nRight = int( ( nWinRight - nWinLeft - NBOXLEN - nLength ) / 2 )
nCkCol = nRight + 2
* we need at least 13 columns for the quit pads, and enough for
* the checkbox table itself
if nWinRight - nWinLeft < max( NTWOPADS, NBOXLEN + nLength )
activate screen
? "Too few columns in this window - aborting"
wait
cancel
endif
* determine rows to use if window is small
nRo = min( nRows, min( nLast - nDown, nWinBot - nWinTop - NEXTRAROWS ) )
if nRo < 1
activate screen
? "Too few rows in this window - aborting"
wait
cancel
endif
* test for mouse support and set boundaries of active click area
* nMx variables represent absolute screen positions of the edges
* of the checkbox table
lGotMouse = .F.
if type( "nG_MusClick" ) = "N"
lGotMouse = .T.
nMTop = nWinTop + nDown - 1 && row above table
nMLeft = nWinLeft + nRight && left edge of table
nMBot = nMTop + nRo + 1 && row below table
nMRight = nMleft + NBOXLEN + nLength - 1 && right edge
endif
* position quit pads ( they are displayed by Smultpick )
* nLpad and nRpad are column offsets within the active window
* of the two pads, " OK " and "Cancel"
if NPADLEN + nLength > NTWOPADS
nLpad = nRight
else
nLpad = int( ( nWinRight - nWinLeft ) / 4 ) - ( NPADLEN / 2 )
endif
nRpad = nWinRight - nWinLeft - NPADLEN - nLpad
* initialize display as if "Home" had been pressed
* nTop is the index into the array of the element to be shown
* on the top row of the table
* nHigh is the index into the array of the element to be shown
* highlighted ( the current element )
* lOnPicks is the "focus"; .T. means we are in the pick table,
* not on the quit pads
nTop = 1
nHigh = nTop
keyboard "{Home}"
lOnPicks = .T.
* commence main key-handling loop
do while .T.
nKey = inkey()
if nKey = 0
loop
endif
do case
case nKey = 23 && Ctrl-End
exit
case nKey = 27 && Escape
if YesQuit()
exit
endif
case nKey = 79 .or. nKey = 111 && 'O' or 'o'
exit
case nKey = 67 .or. nKey = 99 && 'C' or 'c'
if YesQuit()
exit
endif
case nKey = 9 && Tab
if lOnPicks
lOk = .T. && default tab is "OK"
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cNorm
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cNorm
@ nLast, nLpad + NPADLEN / 2 say ""
else
do SmultPick
endif
lOnPicks = .not. lOnPicks
case lGotMouse .and. nKey = nG_MusClick && mouse click
store chr(255) to cMrow, cMcol
call MUSCLICK with cMrow, cMcol
nMrow = asc( cMrow )
nMcol = asc( cMcol )
if nMrow >= nMTop .and. nMrow <= nMBot .and. ;
nMcol >= nMLeft .and. nMcol <= nMRight && in active area
nAt = nHigh - nTop + nMTop + 1
do case
case nMrow = nAt
keyboard chr( 13 )
case nMrow = nMTop
keyboard "{PgUp}"
case nMrow = nMBot
keyboard "{PgDn}"
case nMrow > nAt
do while nAt < nMrow
keyboard "{DNARROW}"
nAt = nAt + 1
enddo
case nMrow < nAt
do while nAt > nMrow
keyboard "{UPARROW}"
nAt = nAt - 1
enddo
endcase
else
* if it was on a pad
if nMrow = nWinTop + nLast
if nMcol >= nWinLeft + nLpad .and. nMcol < nWinLeft + ;
nLpad + NPADLEN
keyboard "O"
loop
endif
if nMcol >= nWinLeft + nRpad .and. nMcol < nWinLeft + ;
nRpad + NPADLEN
keyboard "C"
loop
endif
endif
keyboard "{Esc}"
endif
otherwise
if lOnPicks
do case
case nKey = 26 && Home
nTop = 1
nHigh = nTop
do SMultPick
case nKey = 2 && End
nTop = nElems - nRo + 1
nHigh = nElems
do SMultPick
case nKey = 24 && down arrow
if nHigh = nTop + nRo - 1 .or. nHigh = nElems
keyboard "{PgDn}"
else
@ nHigh - nTop + nDown, nRight say ""
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cNorm
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cNorm
nHigh = nHigh + 1
@ row() + 1, nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) +cBoxr color &cHigh
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cHigh
@ row(), nCkCol say ""
endif
case nKey = 5 && up arrow
if nHigh = nTop
keyboard "{PgUp}"
else
@ nHigh - nTop + nDown, nRight say ""
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cNorm
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cNorm
nHigh = max( 1, nHigh - 1 )
@ row() - 1, nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cHigh
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cHigh
@ row(), nCkCol say ""
endif
case nKey = 32 .or. nKey = 13 && space and enter are toggles
&cArray.[ nHigh, 2 ] = .not. &cArray[ nHigh, 2 ]
@ row(), nCkCol say iif( &cArray.[ nHigh, 2], cChar, " " ) ;
color &cHigh
@ row(), ncKCol say ""
case nKey = 3 && PgDn
if nHigh = nTop + nRo - 1 .or. nHigh = nElems
nTop = min( nHigh, nElems - nRows + 1 )
do SmultPick
else
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cNorm
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cNorm
nHigh = nTop + nRo - 1
@ nDown + nRo - 1, nRight say ""
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cHigh
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cHigh
@ row(), nCkCol say ""
endif
case nKey = 18 && PgUp
if nHigh = nTop
nTop = max( 1, nHigh - nRo + 1 )
do SmultPick
else
nHigh = nTop
@ nDown, nRight say ""
@ row(), nRight say cBoxl + iif( &cArray.[ nHigh, 2], ;
cChar, " " ) + cBoxr color &cHigh
@ row(), col() say left( &cArray.[ nHigh, 1 ] ;
+ space( nLength ), nLength ) color &cHigh
@ row(), nCkCol say ""
endif
endcase
else
do case
case nKey = 32 .or. nKey = 4 .or. nKey = 19 && space, r & l
lOk = .not. lOk
@ nLast, iif( lOk, nLpad, nRpad ) + NPADLEN / 2 say ""
case nKey = 13 && and enter quits
if lOK
keyboard "{CTRL-END}"
else
keyboard "{ESC}"
endif
endcase
endif
endcase
enddo
if cEsc ="ON"
set escape on
endif
RETURN
*-- EoP: MultiPick
PROCEDURE SMultPick
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 01/16/1993
*-- Notes.......: Does screen display loop for Multipick procedure.
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: Original function 01/16/1993.
*-- Calls.......: None
*-- Called by...: Multipick
*-- Usage.......: DO SMultpick
*-- Parameters..: None, but procedure uses various variables set by the
*-- parent Multipick procedure.
*-------------------------------------------------------------------------------
private nThisOff, nThisRow, nThisElem, nHiRow, nR
nThisOff = 0
nR = min( nRo, nElems - nTop + 1 )
do while nThisOff < nRo
nThisRow = nDown + nThisOff
nThisElem = nTop + nThisOff
if nThisoff < nR
if nThisElem = nHigh
@ nThisRow, nRight say cBoxl + iif( &cArray.[ nThisElem, 2], ;
cChar, " " ) + cBoxr color &cHigh
@ nThisRow, col() say left( &cArray.[ nThisElem, 1 ] ;
+ space( nLength ), nLength ) color &cHigh
nHiRow = nThisRow
else
@ nThisRow, nRight say cBoxl + iif( &cArray.[ nThisElem, 2], ;
cChar, " " ) + cBoxr color &cNorm
@ nThisRow, col() say left( &cArray.[ nThisElem, 1 ] ;
+ space( nLength ), nLength ) color &cNorm
endif
else
@ nThisRow, nRight say space( nCkCol + len( cBoxr ) + nLength )
endif
nThisoff = nThisOff + 1
enddo
@ nLast, nLpad say " Done " color &cQuit
@ nLast, nRpad say "Cancel" color &cQuit
@ nHiRow, nCkCol say ""
RETURN
*-- EoP: SMultPick
FUNCTION YesQuit
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/24/1993
*-- Notes.......: Asks whether to quit and cancel changes; does so if yes.
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/.24/1993 -- Original Release
*-- Calls.......: YnMouse() Function in SCREENS.PRG
*-- Called by...: Multipick
*-- Usage.......: YesQuit()
*-- Example.....: ? Yesquit()
*-- Parameters..: None
*-- Returns.....: Logical, .T. for "Yes" or .F. for "No"
*-- Side effects: If "Yes", restores cArray[ , 2 ] values from cTemp
*-------------------------------------------------------------------------------
private nX, lRet
lRet = YnMouse( "","Do you wish to restore", ;
"the original selection","and leave this routine?" )
if lRet
nX = 1
do while nX <= nElems
&cArray[ nX, 2 ] = cTemp[ nX ]
nX = nX + 1
enddo
endif
RETURN lRet
*-- EoF: YesQuit()
FUNCTION YnMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/28/1993
*-- Notes.......: Returns .T. or .F. answer to question without leaving
*-- mouse droppings. Will not respond to left arrow properly
*-- unless set( "ESCAPE" ) is off.
*-- *******************************
*-- **** REQUIRES MUSCLICK.BIN ****
*-- *******************************
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/93 - original function
*-- 02/28/93 - revised to support right and left arrows
*-- Calls.......: HighColors() Function in COLOR.PRG
*-- Center Procedure in PROC.PRG ( if centering )
*-- Called by...: Any
*-- Usage.......: YnMouse( <cColors>, <cP1> [, <cP2>...] [,<lYes>] )
*-- Example.....: ? YnMouse( "", "Are you sure?" )
*-- Parameters..: cColors - String, either blank or holding desired
*-- colors as standard [ , enhanced [, border ] ]
*-- cP<n> - One or more strings of prompt characters.
*-- < only 7 may be passed as literals using
*-- dBASE IV 1.5 >. They will be printed
*-- one below the other. There may not in
*-- any event be more than the number of
*-- useable screen rows less 6; the parameters
*-- line will have to be changed to use more
*-- than 20.
*-- As furnished, the justification of the
*-- prompt strings is flush left. To center
*-- them, see the commented lines in the code.
*-- Centering uses the Center procedure in PROC.PRG.
*-- lYes - A logical .T. if the default answer is "Yes"
*-- This must be the last parameter, but it may
*-- follow any number of prompt lines.
*-- Returns.....: Logical, .T. for "Yes" or .F. for "No"
*-------------------------------------------------------------------------------
parameters cColors, cP01, cP02, cP03, cP04, cP05, cP06, cP07, cP08,;
cP09, cP10, cP11, cP12, cP13, cP14, cP15, cP16, cP17, cP18,;
cP19, cP20, lYes
private cYn, nX, lY, nParams, nRows, nCols, cWhich, nBot, nTop, nLeft
private cColrs, cPads, nLpad, nRpad, lRet, nScr
* obtain number of prompts, and default answer if provided
nParams = pcount() - 1
lY = .F.
* if we have 22 parameters, last must be the default answer
if nParams = 21
lY = lYes
* otherwise look at the last parameter's type--if it is logical
* that's the default answer and not a prompt
else
cWhich = "cP" + right( str( 100 + nParams ), 2 )
if type( cWhich ) = "L"
lY = &cWhich
nParams = nParams - 1
endif
endif
* we need six rows for top and bottom borders, space before prompts,
* space after prompts, yes/no pads and space after them
nRows = nParams + 6
nScr = iif( "43" $ set( "DISPLAY" ), 43, 25 )
* don't overwrite messages, status or scoreboard
nBot = nScr - 2
nTop = 0
if set( "STATUS" ) = "ON"
nBot = nBot - 2
else
if set( "SCOREBOARD" ) = "ON"
nTop = 1
endif
endif
if nRows > nBot - nTop
activate screen
? "Too many prompt lines for screen size - aborting"
wait
cancel
endif
* find longest prompt line and window width it requires including
* a space at both ends
nX = 1
nCols = 13 && 11 spaces for the pads, 2 for border
do while nX <= nParams
cWhich = "cP" + right( str( 100 + nX ), 2 )
nCols = max( nCols, len( trim( &cWhich ) ) + 2 )
nX = nX + 1
enddo
* round up to even number of columns in order to center the window
nCols = 2 * ceiling( nCols/ 2 )
if nCols > 80
activate screen
? "Prompts are too long for screen - aborting"
wait
cancel
endif
* calculate screen row of top and bottom of centered window
nTop = max( nTop, int( ( nScr - nRows ) / 2 ) )
nBot = nTop + nRows
* and screen column of left edge
nLeft = 39 - nCols / 2
* obtain colors to use, using highlight for pads
cColrs = iif( "" # cColors, cColors, set( "ATTRIBUTES" ) )
if "&" $ cColrs
cColrs = left( cColrs, at( "&", cColrs ) - 1 )
endif
cPads = HighColors( cColrs )
* calculate column positions of yes/no pads
nLpad = int( ( nCols - 2 ) / 4 ) - 2
nRpad = nCols - nLpad - 6
* now open the window and print prompts
define window cYn from nTop, nLeft to nBot, nLeft + nCols color &cColrs
activate window cYn
nX = 1
do while nX <= nParams
cWhich = "cP" + right( str( 100 + nX ), 2 )
* To change from flush left to centered justification of the prompts,
* uncomment the next code line and comment out the one following.
* You will then need the "Center" procedure in PROC.PRG.
* do Center with nX, nCols, "", &cWhich
@ nX, 1 say &cWhich
nX = nX + 1
enddo
* print pads
@ nX + 1, nLpad say " Yes " color &cPads
@ nX + 1, nRpad say " No " color &cPads
@ nX + 1, iif( lY, nLpad, nRpad ) + 2 say ""
* and begin a loop that may last forever
clear typeahead
do while .T.
nk = inkey()
if nk = 0
loop
endif
do case
case nk = 89 .or. nk = 121 && 'Y' or 'y'
lRet = .T.
exit
case nK = 78 .or. nK = 110 .or. nK = 27 && 'N' or 'n' or Esc
lRet = .F.
exit
case nK = 13 .or. nK = 23 && Enter or Ctrl-End
lRet = lY
exit
case nK = 4 .or. nK = 19 && right or left arrow
lY = .not. lY
@ nX + 1, iif( lY, nLpad, nRpad ) + 2 say ""
case type( "nG_MusClic" ) = "N" .and. nk = nG_MusClic
store chr(255) to cMrow, cMcol
call MUSCLICK with cMrow, cMcol
nMrow = asc( cMrow )
nMcol = asc( cMcol )
if nMrow = nTop + nX + 2 && one more for border
if nMcol >= nLpad + nLeft .and. nMcol < nLpad + nLeft + 5
lRet = .T.
exit
endif
if nMcol >= nRpad + nLeft .and. nMcol <nRpad + nLeft + 5
lRet = .F.
exit
endif
endif
endcase
enddo
deactivate window cYn
release window cYn
RETURN lRet
*-- EoF: YnMouse()
FUNCTION CWnDecode
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: Returns the numeric value of one of the four codes for
*-- edges of the window held in a string of the type returned
*-- by cWnSize. These represent numbers of rows or columns.
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: cWnDecode( <cWnString>,<cEdge>|<nPos> )
*-- Example.....: cWinTop = cWnDecode( cWin, "T" )
*-- Parameters..: cWnString - A string returned by CWnSize
*-- cEdge - A character parameter beginning with one
*-- of the four characters "T","L","B",or "R",
*-- ( upper or lower case ), OR
*-- nPos - A number indicating the position in the
*-- cWnString of the code for the edge.
*-- These correspond to the following:
*-- Window edge cEdge nPos
*-- top T 1
*-- left L 2
*-- bottom B 3
*-- right R 4
*-- Either cEdge or nPos must be furnished,
*-- not both.
*-- Returns.....: numeric value of the row or column; -1 for argument
*-- out of range or cWnString holds garbage or is empty.
*-------------------------------------------------------------------------------
parameters cWnString, xEdge
private nPos, nRet
nRet = -1
if type( "xEdge" ) = "C"
nPos = at( upper( left( xEdge, 1 ) ), "TLBR" )
else
if type( "xEdge" ) = "N"
nPos = xEdge
endif
endif
if nPos > 0 .and. nPos < 5 .and. len( cWnString ) = 4
nRet = asc( substr( cWnString, nPos, 1 ) ) - 1
endif
if nRet > iif( mod( nPos, 2 ) > 0, 43, 80 )
nRet = -1
endif
RETURN nRet
*-- EoF: CWnDecode
FUNCTION CWnSize
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: Returns a string of four characters which are chr()
*-- values of one more each than the top, left, bottom
*-- and right row and column numbers of the usable surface
*-- of the current window, or of the screen. ( one more
*-- to avoid chr( 0 ) problems )
*-- Returns "" if unable to find VDCURSOR.BIN
*-- *******************************
*-- **** REQUIRES VDCURSOR.BIN ****
*-- *******************************
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: nWBsrch() function included
*-- Called by...: Any
*-- Usage.......: cWnSize()
*-- Example.....: cWin = cWnSize()
*-- WinBot = asc( substr( cWin, 3 1 ) )
*-- Parameters..: None
*-- Returns.....: character string of four chr() values, or "" if error
*-- Side effects: Called function nWBsrch disables any error trap
*-------------------------------------------------------------------------------
private nHi, nLo, nL, cV
cV = ""
if file( "VDCURSOR.BIN" )
load VDCURSOR
@ 0,0 say ""
cV = call( "VDCURSOR"," " )
release module VDCURSOR
* reverse bytes so row comes first
cV = right( cV, 1 ) + left( cV, 1 )
* this is the first row, and one more than maximum last
nL = asc( cV ) - 1
nLo = nL
nHi = 44
cV = cV + chr( nL + nWBsrch( nLo, nHi, "Down" ) + 1 )
* first column and one more than last
nL = asc( substr( cV, 2, 1 ) ) - 1
nLo = nL
nHi = 80
cV = cV + chr( nL + nWBsrch( nLo, nHi, "Across" ) + 1 )
endif
RETURN cV
*-- EoF: CWnSize()
FUNCTION nWBsrch
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/06/1993
*-- Notes.......: special binary search routine for window edges
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 02/06/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: cWnSize
*-- Usage.......: nWBsrch( < nLo >, < nHi >, < cDir > )
*-- Example.....: Lastrow = nWBsrch( 0, 44, "Down" )
*-- Parameters..: nLo Number, top row or left column
*-- nHi Number, bottom or right screen edge + 1
*-- cDir char, direction - "Down" or "Across"
*-- Returns.....: number of highest row or column that may be written to.
*-- Side effects: Disables any ON ERROR trap
*-------------------------------------------------------------------------------
parameters nLo, nHi, cDir
private lToohigh, nTry, cD
cD = upper( left( cDir, 1 ) )
do while nHi > nLo + 1
lTooHigh = .F.
nTry = int( ( nHi + nLo ) / 2 )
on error lTooHigh = .T.
if cD $ "DB"
@ nTry, 0 say ""
else
@ 0, nTry say ""
endif
if lToohigh
nHi = nTry - 1
else
nLo = nTry
endif
enddo
on error
RETURN nLo
*-- EoF(): nWBsrch
PROCEDURE SetBorder
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 03/22/1993
*-- Notes.......: This routine is designed as a front-end for the NEWBORDR
*-- routine. It's purpose is to display a sample of the specific
*-- border from a picklist, and allow the user to select
*-- one ...
*-- Written for.: dBASE IV, 2.0
*-- Rev. History: 03/22/1993
*-- Calls.......: NEWBORDR() (Function in SCREEN.PRG)
*-- SHADOW (Procedure in PROC.PRG)
*-- DRAWIT (Procedure in SCREEN.PRG)
*-- Called by...: Any
*-- Usage.......: Do SetBordr with <cColor>
*-- Example.....: Do SetBordr with cWind1
*-- Returns.....: None
*-- Parameters..: cColor = colors for window ...
*-------------------------------------------------------------------------------
parameters cColor
private cWindow,cBorder,cHigh
*-- start off with a few basics
save screen to sBorder && save screen so we can cleanup
cWindow = window() && save current window (if any)
activate screen
cBorder = set("BORDER") && save current border setting, in
&& case user doesn't select one ...
*-- define a window ... note that we're using the current default border
define window wBorder from 5,5 to 15,70 color &cColor.
do shadow with 5,5,15,70
activate window wBorder
cHigh = colorbrk(cColor,2)
@0,40 fill to 8,60 color &cHigh.
@0,40 to 8,60 color &cHigh.
@4,45 say "Test Area" color &cHigh.
*-- create the popup ...
define popup pBorders from 0,0
define bar 1 of pBorders prompt "A) Double"
define bar 2 of pBorders prompt "B) Single"
define bar 3 of pBorders prompt "C) Panel (Normal)"
define bar 4 of pBorders prompt "D) None"
define bar 5 of pBorders prompt "E) Double Top, Single Rest"
define bar 6 of pBorders prompt "F) Single Top, Double Rest"
define bar 7 of pBorders prompt "G) Single Bottom, Double Rest"
define bar 8 of pBorders prompt "H) Double Bottom, Single Rest"
define bar 9 of pBorders prompt "I) Double Top/Bottom, Single Rest"
define bar 10 of pBorders prompt "J) Single Top/Bottom, Double Rest"
define bar 11 of pBorders prompt "K) Single Top/Left, Double Rest"
define bar 12 of pBorders prompt "L) Single Top/Right, Double Rest"
define bar 13 of pBorders prompt "M) Double Top/Left, Single Rest"
define bar 14 of pBorders prompt "N) Double Top/Right, Single Rest"
define bar 15 of pBorders prompt "O) Single Left, Double Rest"
define bar 16 of pBorders prompt "P) Single Right, Double Rest"
define bar 17 of pBorders prompt "Q) Double Left, Single Rest"
define bar 18 of pBorders prompt "R) Double Right, Single Rest"
define bar 19 of pBorders prompt "S) Panel (Thin)"
on popup pBorders do drawit
on selection popup pBorders deactivate popup
*-- Now to play inside the window
activate popup pBorders
*-- if user didn't select _anything_, then return to original ...
if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
set border to &cBorder.
c_Border = cBorder
endif
*-- cleanup
release window wBorder
release popup pBorders
restore screen from sBorder
release screens Border
RETURN
*-- EoP: SetBorder
PROCEDURE DrawIt
*-------------------------------------------------------------------------------
*-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
*-- Date........: 03/22/1993
*-- Notes.......: Used specifically with SETBORDER above, to display the current
*-- selection from the popup.
*-- Written for.: dBASE IV, 2.0
*-- Rev. History: 03/22/1993 -- Original
*-- Calls.......: NewBorder() Function in SCREEN.PRG
*-- Called by...: SetBorder Procedure in SCREEN.PRG
*-- Usage.......: Do DrawIt
*-- Example.....: Do DrawIt
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------
cStyle = left(Prompt(),1)
x = NewBorder(cStyle)
if c_Border = "SINGLE"
set border to single
endif
if c_Border = "NONE"
@0,40 say space(21) color &cHigh.
@8,40 say space(21) color &cHigh.
nCounter = 0
do while nCounter < 8
nCounter = nCounter + 1
@nCounter,40 say space(1) color &cHigh.
@nCounter,60 say space(1) color &cHigh.
enddo
else
@0,40 to 8,60 color &cHigh.
endif
RETURN
*-- EoP: DrawIt
FUNCTION Wait4Key
*-------------------------------------------------------------------------------
*-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
*-- GeoApplications, Tucson, Arizona
*-- Date........: 03/24/1993
*-- Notes.......: Time-out option for a READ screen.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/24/1993 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: @x,y GET <fieldname> when Wait4Key(<nSeconds>)
*-- Example.....: @10,10 get m->cTest when Wait4Key(5)
*-- Returns.....: logical -- .t. if key pressed within nSeconds, .f. if not.
*-- Parameters..: nSeconds = how long to wait for time-out.
*-------------------------------------------------------------------------------
parameters nSeconds
private nDummy, lKeyPressd
nDummy = inkey(nSeconds)
if nDummy = 0 && no keypress
*-- abort the read
keyboard chr(27) && send an <Esc>
lKeyPressd = .f.
else
*-- keyboard the character
keyboard chr(nDummy)
lKeyPressd = .t.
endif
RETURN lKeyPressd
*-- EoF: Wait4Key()
*-------------------------------------------------------------------------------
*-- Library functions included for convenience
*-------------------------------------------------------------------------------
FUNCTION NormColors
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/23/1993
*-- Notes.......: Returns the "normal" portion of a color string
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NormColors( <cColor> )
*-- Example.....: ? NormColors( "N/BG,BG+/N,W+/B" )
*-- Parameters..: cColor - String holding colors
*-- Returns.....: Character, normal color portion of string.
*-------------------------------------------------------------------------------
parameters cColor
private cRet
cRet = cColor
if "," $ cRet
cRet = left( cRet, at( ",", cRet ) - 1 )
endif
RETURN upper( ltrim( trim ( cRet ) ) )
*-- EoF: NormColors()
FUNCTION HighColors
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/23/1993
*-- Notes.......: Returns the "highlight" portion of a color string
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/23/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: HighColors( <cColor> )
*-- Example.....: ? HighColors( "N/BG,BG+/N,W+/B" )
*-- Parameters..: cColor - String holding colors
*-- Returns.....: Character, highlight color portion of string.
*-- Returns empty string if no such portion.
*-------------------------------------------------------------------------------
parameters cColor
private cRet
cRet = ""
if "," $ cColor
cRet = substr( cColor, at( ",",cColor ) + 1 )
if "," $ cRet
cRet = left( cRet, at( ",", cRet ) - 1 )
endif
endif
RETURN upper( ltrim( trim( cRet ) ) )
*-- EoF: HighColors()
FUNCTION ForeColor
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons CIS 70160,340
*-- Date........: 02/24/1993
*-- Notes.......: Returns foreground part of color string.
*-- Written for.: dBASE IV, Version 1.5.
*-- Rev. History: 02/24/1993 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ForeColor( <cColor> )
*-- Example.....: ? ForeColor( "N/BG" )
*-- Parameters..: cColor - String holding color foreground and background
*-- Returns.....: Character, string with foreground portion of the color
*-------------------------------------------------------------------------------
parameters cColor
private cRet
cRet = upper( trim( ltrim( cColor ) ) )
if "/" $ cRet
cRet = left( cRet, at( "/", cRet ) - 1 )
endif
if "*" $ cColor
cRet = cRet + "*"
endif
if "+" $ cColor
cRet = cRet + "+"
endif
RETURN cRet
*-- EoF: ForeColor()
PROCEDURE Center
*-------------------------------------------------------------------------------
*-- Programmer..: Miriam Liskin
*-- Date........: 05/24/1991
*-- Notes.......: Centers text on the screen with @says
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: This and all other procedures/functions listed in this
*-- file attributed to Miriam Liskin came from "Liskin's
*-- Programming dBASE IV Book". Very good, worth the money.
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
*-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
*-- Note that the color field may be blank: ""
*-- Returns.....: None
*-- Parameters..: nLine = Line or Row for @/Say
*-- nWidth = Width of screen
*-- cColor = Colors to be used ("Forg/Back") (may be nul "", in
*-- order to use the default colors of window/screen)
*-- cText = Message to center on screen
*-------------------------------------------------------------------------------
parameters nLine,nWidth,cColor,cText
private nCol
nCol = (nWidth - len(cText)) /2
@nLine,nCol say cText color &cColor.
RETURN
*-- EoP: Center
FUNCTION ArrayRows
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (JPARSONS)
*-- Date........: 03/01/1992
*-- Notes.......: Number of Rows in an array
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: ArrayRows("<aArray>")
*-- Example.....: n = ArrayRows("aTest")
*-- Returns.....: numeric
*-- Parameters..: aArray = Name of array
*-------------------------------------------------------------------------------
parameters aArray
private nHi, nLo, nTrial, nDims
nLo = 1
nHi = 1170
if type( "&aArray[ 1, 1 ]" ) = "U"
nDims = 1
else
nDims = 2
endif
do while .T.
nTrial = int( ( nHi + nLo ) / 2 )
if nHi < nLo
exit
endif
if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
nHi = nTrial - 1
else
nLo = nTrial + 1
endif
enddo
RETURN nTrial
*-- EoF: ArrayRows()
PROCEDURE ReColor
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (Jparsons)
*-- Date........: 04/23/1992
*-- Notes.......: Restores colors to those held in a string of the form
*-- returned by set("ATTRIBUTE").
*-- Written for.: dBASE IV, Versions 1.0 - 1.5.
*-- Rev. History: 04/23/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DO ReColor WITH <cColors>
*-- Example.....: DO Recolor WITH OldColors
*-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
*-- Returns.....: None
*-- Side effects: Changes the screen colors.
*-------------------------------------------------------------------------------
parameters cColors
private cThis, cNext, nAt, cLeft, nX, cAreas
cAreas = " NORMHIGHBORDMESSTITLBOX INFOFIEL"
cLeft = cColors + ", "
nX = 0
do while nX < 8
nX = nX + 1
cThis = substr( cAreas, 4 * nX, 4 )
if nX = 3
nAt = at( "&", cLeft )
cNext = left( cLeft, nAt - 2 )
cLeft = substr( cLeft, nAt + 3 )
SET COLOR TO , , &cNext
else
nAt = at( ",", cLeft )
cNext = left( cLeft, nAt - 1 )
cLeft = substr( cLeft, nAt + 1 )
SET COLOR OF &cThis TO &cNext
endif
enddo
RETURN
*-- EoP: ReColor
*-------------------------------------------------------------------------------
*-- EoP: SCREEN.PRG
*-------------------------------------------------------------------------------